;;;-*-lisp-*-

;;; The GJC lisp benchmarks.

;; This benchmark tests raw structure referencing, function calling,
;; dispatching, and arithmetic speed. Tail recursion optimization
;; and good register allocation are also applicable.

;; A CLIPPER does line-clipping by a half-plane, they may be 
;; cascaded to clip for arbitrary convex windows.
;; The equation of the half plane is  A*X+B*Y<C
;; If the line is given by the two point formula

;;			  Y2 - Y1   Y1 - Y
;;              	  ------- = ------
;;			  X2 - X1   X1 - X

;; And the edge of the half plane by

;;         		   B Y + A X = C

;; Then the intercept is

;;	   B (X1 Y2 - X2 Y1) + C (X2 - X1)      A (X2 Y1 - X1 Y2) + C (Y2 - Y1)
;;     X = -------------------------------  Y = -------------------------------
;;	      B (Y2 - Y1) + A (X2 - X1)		   B (Y2 - Y1) + A (X2 - X1)

#.(PROGN #+Maclisp (sstatus feature numdcl)
	 #+Maclisp (sstatus feature subrcall)
	 #+Lispm   (sstatus feature arithcheck)
	 nil)

#+numdcl
(DECLARE (FLONUM (DIST FLONUM FLONUM FLONUM FLONUM)
		 (DET FLONUM FLONUM FLONUM FLONUM)
		 #+arithcheck (C-QUOTIENT-INTERNAL FLONUM FLONUM)
		 (X-INTERCEPT-N FLONUM FLONUM FLONUM FLONUM FLONUM)))

(DEFUN DIST (A X B Y) (PLUS (TIMES A X) (TIMES B Y)))
(DEFUN DET (X1 Y1 X2 Y2) (DIFFERENCE (TIMES X1 Y2) (TIMES X2 Y1)))

(DEFUN X-INTERCEPT-N (X1 X2 DET B C)
       (PLUS (TIMES B DET)
	     (TIMES C (DIFFERENCE X2 X1))))

(DEFMACRO X-INTERCEPT (X1 X2 DET B C Q)
	  `(C-QUOTIENT (X-INTERCEPT-N ,X1 ,X2 ,DET ,B ,C) ,Q))

(DEFMACRO Y-INTERCEPT (Y1 Y2 DET A C Q)
	  `(C-QUOTIENT (X-INTERCEPT-N ,Y1 ,Y2 (MINUS ,DET) ,A ,C) ,Q))

(DEFMACRO C-QUOTIENT (X Y)
	  #-arithcheck `(quotient ,x ,y)
	  #+arithcheck `(c-quotient-internal ,x ,y))

#+arithcheck
(progn 'compile
(defvar epsilon 0.00001)
#+numdcl (declare (flonum epsilon))
(defun c-quotient-internal (x y)
       (if (lessp (abs x) epsilon) x (quotient x y)))
)


(DEFVST CLIPPER
	(EXPR #'CLIPPER)
	#+subrcall SUBR
	S
	A
	B
	C)

(DEFMACRO MAKE-CLIPPER (&REST L) `(SETTUP-CLIPPER (CONS-A-CLIPPER ,@L)))

(DEFUN SETTUP-CLIPPER (SELF)
       #+SUBRCALL (SETF (CLIPPER-SUBR SELF)
			(GETSUBR (CLIPPER-EXPR SELF)))
       SELF)

(DEFUN CLIPPER (SELF X1 Y1 X2 Y2)
       #+numdcl (DECLARE (FLONUM  X1 Y1 X2 Y2))
       (LET ((A (CLIPPER-A SELF))
	     (B (CLIPPER-B SELF))
	     (C (CLIPPER-C SELF))
	     (S (CLIPPER-S SELF)))
	    #+numdcl (DECLARE (FLONUM A B C))
	    (LET ((D1 (DIST A X1 B Y1))
		  (D2 (DIST A X2 B Y2)))
		 #+numdcl (DECLARE (FLONUM D1 D2))
		 (COND ((LESSP D1 C)
			(IF (LESSP D2 C)
			    (CLIPPER-CALL S X1 Y1 X2 Y2)
			    (LET ((Q (DIFFERENCE D1 D2))
				  (D (DET X1 Y1 X2 Y2)))
				 #+numdcl (DECLARE (FLONUM Q D))
				 (CLIPPER-CALL
				  S X1 Y1
				  (X-INTERCEPT X1 X2 D B C Q)
				  (Y-INTERCEPT Y1 Y2 D A C Q)))))
		       ((LESSP D2 C))
		       (T
			(LET ((Q (DIFFERENCE D1 D2))
			      (D (DET X1 Y1 X2 Y2)))
			     #+numdcl (DECLARE (FLONUM Q D))
			     (CLIPPER-CALL
			      S
			      (X-INTERCEPT X1 X2 D B C Q)
			      (Y-INTERCEPT Y1 Y2 D A C Q)
			      X2 Y2)))))))

(DEFUN DRAW-LINE (IGNORE-SELF IGNORE2 IGNORE3 IGNORE4 IGNORE5) NIL)

(DEFUN CLIPPER-CALL (CLIPPER X1 Y1 X2 Y2)
       #+subrcall
       (subrcall nil (clipper-subr clipper) clipper x1 y1 x2 y2)
       #-subrcall
       (funcall (clipper-expr clipper) clipper x1 y1 x2 y2)
       )
	
#+subrcall
(PROGN 'COMPILE

(DEFUN TRAMP (SELF X1 Y1 X2 Y2)
       (FUNCALL (CLIPPER-EXPR SELF) SELF X1 Y1 X2 Y2))

(DEFVAR GETSUBR T)

(DEFUN GETSUBR (X)
       (OR (AND GETSUBR (ATOM X) (GET X 'SUBR))
	   (GET 'TRAMP 'SUBR)
	   (GETSUBR (ERROR "No Trampoline" 'TRAMP 'WRNG-TYPE-ARG))))
)


;; The actual test.
;; Remember, A*X+B*Y<C, so for horizonal and vertical lines,
;; B=0 Xc<C/A and A=0 Yc<C/B.

#.`',(SETQ ZERO 0.0 ONE 1.0 LOW 0.0 HI 1.0)

(DEFUN MAKE-TEST-CLIPPER ()
       (MAKE-CLIPPER					; Y < HI
	A #.ZERO
	B #.ONE
	C #.HI
	S (MAKE-CLIPPER					; Y > LOW
	   A #.ZERO
	   B (MINUS #.ONE)
	   C #.LOW
	   S (MAKE-CLIPPER				; X < HI
	      A #.ONE
	      B #.ZERO
	      C #.HI
	      S (MAKE-CLIPPER				; X > LOW
		 A (MINUS #.ONE)
		 B #.ZERO
		 C #.LOW
		 S  (MAKE-CLIPPER
		     EXPR #'DRAW-LINE))))))

(DEFVAR CLIPPER (MAKE-TEST-CLIPPER))


(DEFMACRO TIME-DIFFERENCE-NORMALIZE (X Y)
  #+LISPM `(* (// 1000000. 60.) (TIME-DIFFERENCE ,X ,Y))
  #+MACLISP  `(- ,X ,Y)
  #+NIL  `(- ,X ,Y))

(DEFMACRO SYS-RUNTIME ()
  #+LISPM '(TIME)
  #+MACLISP '(RUNTIME)
  #+NIL '(RUNTIME))

(DEFMACRO DEF-TEST-LOOP (NAME . BODY)
	  `(DEFUN (,NAME TEST-LOOP-EXPR #+subrcall TEST-LOOP-SUBR) (N)
		  (DECLARE (FIXNUM N))
		  (DO ((START-TIME (SYS-RUNTIME))
	       (J 1 (1+ J)))
		      ((> J N)
		       (TIME-DIFFERENCE-NORMALIZE (SYS-RUNTIME) START-TIME))
		      (DECLARE (FIXNUM J))
		      ,@BODY)))

#+NUMDCL (DECLARE (FLONUM (TESTPOINT)))

(DEFUN TESTPOINT ()
       (DIFFERENCE (TIMES #.(PLUS ONE ONE ONE)
			  (FLOAT (RANDOM))
			  #.(QUOTIENT 1 (FLOAT (LSH -1 -1))))
		   #.ONE))

(DEF-TEST-LOOP CLIPPER-CALL
	       (CLIPPER-CALL CLIPPER
			     (TESTPOINT)
			     (TESTPOINT)
			     (TESTPOINT)
			     (TESTPOINT)))

(DEF-TEST-LOOP TESTPOINT
	       (TESTPOINT)
	       (TESTPOINT)
	       (TESTPOINT)
	       (TESTPOINT))

(DEFUN TEST-LOOP (NAME N)
       (LET ((TIME (LET ((P (GETL NAME '(TEST-LOOP-EXPR #+subrcall TEST-LOOP-SUBR))))
			(CASEQ (CAR P)
			       ((TEST-LOOP-EXPR)
				(FUNCALL (CADR P) N))
			       #+subrcall
			       ((TEST-LOOP-SUBR)
				(SUBRCALL NIL (CADR P) N))))))
	    (FORMAT MSGFILES
		    "}&}D loops in }D microseconds = }D microseconds per loop}%"
		    N TIME
		    (// TIME N))))

(DEFUN TEST-RUN (NAME END &OPTIONAL (START 1) (STEP 1))
       (FORMAT MSGFILES
	       "}
	       }&Running clip test }S from }D to }D by step }D.}
	       }%----------------------------------------------------------}%"
	       NAME START END STEP)
       (DO ((K START (+ K STEP))
	    (TIME (SYS-RUNTIME)))
	   ((> K END)
	    (FORMAT MSGFILES
		    "}&------------------------------------------}
		    }%End of test, }D microseconds total.}%"
		    (time-difference-normalize (sys-runtime) time)))
	   (test-loop name k)))